##
## Commands / Functions that do DB modification / viewing

package Purl::database;
use strict;

use constant NONE => -1;


## DB Access Functions

sub owner {
    my $dbref = shift;
    return $main::objects[$dbref]{"owner"};
}

## Building Commands

## Object Commands

sub addObject {
    my ( $maker, $name, $type ) = @_;
    my ( $id, $found );
    $found = 0;
    for ( $id = 0; ( $id <= $#main::objects ); $id++ ) {
        if ( $main::objects[$id]{"type"} == NONE ) {
            $found = 1;
            last;
        }
    }
    $id = $#main::objects + 1 if ( !$found );
    $main::objects[$id]{"name"}     = $name;
    $main::objects[$id]{"type"}     = $type;
    $main::objects[$id]{"activeFd"} = NONE;
    $main::objects[$id]{"owner"}    = $maker;
    Purl::comm::sendTextToPlayer( $maker,
        $main::objects[$id]{"name"} . " has been created as #" . $id . "." )
        if ( $maker != 0 );
    return $id;
}

sub addContents {
    my ( $addto, $add ) = @_;

    # Whatever you do, don't let any commas get in here
    $add =~ s/,//g;

    if ( length( $main::objects[$addto]{"contents"} ) > 0 ) {
        $main::objects[$addto]{"contents"} .= "," . $add;
    }
    else {
        $main::objects[$addto]{"contents"} = $add;
    }
    $main::objects[$add]{"location"} = $addto;
}

sub findContents {
    my ( $container, $arg, $type ) = @_;
    my (@list);
    $arg =~ tr/A-Z/a-z/;
    @list = split( /,/, $main::objects[$container]{"contents"} );
    my ($e);
    if ( substr( $arg, 0, 1 ) eq "#" ) {
        foreach $e (@list) {
            if ( ( "#" . $e ) eq $arg ) {
                return $e
                    if ( ( !$type )
                    || ( $main::objects[$e]{"type"} == $type ) );
            }
        }
        return NONE;
    }

    #First an exact match
    foreach $e (@list) {
        my $name = $main::objects[$e]{"name"};
        $name =~ tr/A-Z/a-z/;
        if ( $name eq $arg ) {
            return $e
                if ( ( !$type ) || ( $main::objects[$e]{"type"} == $type ) );
        }

        #TinyMUD semicolon stuff
        if ( $main::objects[$e]{"type"} == $main::exit ) {
            my @elist = split( /;/, $main::objects[$e]{"name"} );
            foreach my $f (@elist) {
                $f =~ tr/A-Z/a-z/;
                if ( $f eq $arg ) {
                    return $e
                        if ( ( !$type )
                        || ( $main::objects[$e]{"type"} == $type ) );
                }
            }
        }
    }

    #Okay, now an inexact match
    foreach $e (@list) {
        my $name = $main::objects[$e]{"name"};
        $name =~ tr/A-Z/a-z/;
        if ( substr( $name, 0, length($arg) ) eq $arg ) {
            return $e
                if ( ( !$type ) || ( $main::objects[$e]{"type"} == $type ) );
        }

        #TinyMUD semicolon stuff
        if ( $main::objects[$e]{"type"} == $main::exit ) {
            my @elist = split( /;/, $main::objects[$e]{"name"} );
            foreach my $f (@elist) {
                $f =~ tr/A-Z/a-z/;
                if ( substr( $f, 0, length($arg) ) eq $arg ) {
                    return $e
                        if ( ( !$type )
                        || ( $main::objects[$e]{"type"} == $type ) );
                }
            }
        }
    }
    return NONE;
}

sub removeContents {
    my ( $container, $id ) = @_;
    my @list = split( /,/, $main::objects[$container]{"contents"} );
    $main::objects[$container]{"contents"} = "";
    foreach my $e (@list) {
        &addContents( $container, $e ) if ( $e ne $id );
    }
}

sub parseFlagLetters {
    my $dbref      = shift;
    my $flagstring = "";
    my %typeAbbrv = ( "player", "P", "thing", "T", "exit", "E", "room", "R" );
    foreach my $type ( keys %typeAbbrv ) {
        $flagstring .= $typeAbbrv{$type}
            if ( $main::objects[$dbref]{"type"} == ${$type} );
    }
    foreach my $flag ( keys %main::flags ) {
        $flagstring .= $main::flags{$flag}{"symbol"}
            if (
            $main::objects[$dbref]{"flags"} & $main::flags{$flag}{"value"} );
    }
    return $flagstring;
}

sub parseNameDbref {
    my %args = @_;
    if ( Purl::tests::controls( $args{actor}, $args{target} ) ) {
        Purl::comm::sendTextToPlayer( $args{actor},
                  $main::objects[ $args{target} ]{"name"}
                . "(#$args{target}"
                . parseFlagLetters( $args{target} )
                . ")" );
    }
    else {
        Purl::comm::sendTextToPlayer( $args{actor},
            $main::objects[ $args{target} ]{"name"} );
    }
}

sub describeBody {
    my %args   = @_;
    my $found  = 0;
    my $return = "";
    if ( $args{details} ) {
        my $line = parseNameDbref( $args{actor}, $args{target} )
            . "\nOwner: "
            . $main::objects[ $main::objects[ $args{target} ]{"owner"} ]
            {"name"}
            . " Home: #"
            . int( $main::objects[ $args{target} ]{"home"} );
        my ( $key, $val );
        while ( $key = each(%main::flags) ) {
            if ( $main::objects[ $args{target} ]{"flags"}
                & $main::flags{$key}{"value"} )
            {
                $line .= " " . $key;
            }
        }
        $return .= $line . "\n";
        if ( $main::objects[ $args{target} ]{"type"} == $main::player ) {
            my ($tz) = $main::objects[ $args{target} ]{"tz"};
            if ( $tz eq "" ) {
                $return .= "Time Zone: Not Set\n";
            }
            else {
                my ($prefix) = "";
                if ( $tz < 0 ) {
                    $tz     = -$tz;
                    $prefix = "-";
                }
                my ( $hours, $mins ) = ( int( $tz / 60 ), $tz % 60 );
                $return .= "Time Zone: "
                    . sprintf( "%s%02d:%02d", $prefix, $hours, $mins ) . "\n";
            }
        }
        if ( Purl::tests::isWizard( $args{to} )
            || ( $main::objects[ $args{target} ]{"owner"} == $args{to} ) )
        {
            $return
                .= "Fail: " . $main::objects[ $args{target} ]{"fail"} . "\n"
                if ( $main::objects[ $args{target} ]{"fail"} ne "" );
            $return
                .= "Ofail: " . $main::objects[ $args{target} ]{"ofail"} . "\n"
                if ( $main::objects[ $args{target} ]{"ofail"} ne "" );
            $return
                .= "Odrop: " . $main::objects[ $args{target} ]{"odrop"} . "\n"
                if ( $main::objects[ $args{target} ]{"odrop"} ne "" );
            $return .= "Success: "
                . $main::objects[ $args{target} ]{"success"} . "\n"
                if ( $main::objects[ $args{target} ]{"success"} ne "" );
            $return .= "Osuccess: "
                . $main::objects[ $args{target} ]{"osuccess"} . "\n"
                if ( $main::objects[ $args{target} ]{"osuccess"} ne "" );
            $return
                .= "Lock: " . $main::objects[ $args{target} ]{"lock"} . "\n"
                if ( $main::objects[ $args{target} ]{"lock"} ne "" );
            $return
                .= "Gags: " . $main::objects[ $args{target} ]{"gags"} . "\n"
                if ( $main::objects[ $args{target} ]{"gags"} ne "" );
            $return .= "Site/IP: "
                . $main::objects[ $args{target} ]{"site"} . "/"
                . $main::objects[ $args{target} ]{"ip"} . "\n"
                if ( $main::objects[ $args{target} ]{"ip"} ne "" );
        }
        $return .= "Location: #"
            . int( $main::objects[ $args{target} ]{"location"} ) . "\n";

# if (Purl::tests::isWizard($args{to}) || ($main::objects[$args{target}]{"owner"} == $args{to})) {
# 			if ($main::objects[$args{target}]{"type"} == $main::exit) {
# 				my $args{actor} = int($main::objects[$args{target}]{"action"});
# 				if ($args{actor} == $nowhere) {
# 					$return .=  "Destination: nowhere" . "\n";
# 				} elsif ($args{actor} == $home) {
# 					$return .=  "Destination: home" . "\n";
# 				} else {
# 					$return .=  "Destination: #" . int($main::objects[$args{target}]{"action"}) . "\n";
# 				}
# 			}
# 		}
    }
    else {
        $return .= $main::objects[ $args{target} ]{"name"} . "\n"
            if ( $main::objects[ $args{target} ]{"type"} != $main::exit );
    }
    if ( $main::objects[ $args{target} ]{"description"} eq "" ) {
        $return .= "You see nothing special." . "\n";
    }
    else {
        $return .= $main::objects[ $args{target} ]{"description"} . "\n";
    }
    my ( @list, $desc, $first, $e );
    @list  = split( /,/, $main::objects[ $args{target} ]{"contents"} );
    $desc  = "";
    $first = 1;
    if ($args{details}
        || (!(  $main::objects[ $args{target} ]{"flags"}
                & $main::flags{"dark"}{"value"}
            )
        )
        )
    {
        foreach $e (@list) {
            if ( $args{details} ) {
                $found = 1;
                if ($first) {
                    $first = 0;
                }
                else {
                    $desc .= ", ";
                }
                $desc .= $main::objects[$e]{"name"} . " #" . $e;
            }
            else {
                if (( $main::objects[$e]{"type"} == $main::thing )
                    || (   ( $main::objects[$e]{"type"} == $main::player )
                        && ( $main::objects[$e]{"activeFd"} ne NONE ) )
                    )
                {
                    $found = 1;
                    if ($first) {
                        $first = 0;
                        $desc .= $main::objects[$e]{"name"};
                    }
                    else {
                        $desc .= ", " . $main::objects[$e]{"name"};
                    }
                }
            }
        }
    }
    if ( !$found ) {
        if ( $main::objects[ $args{target} ]{"type"} == $main::room ) {
            if ($args{details}
                || (!(  $main::objects[ $args{target} ]{"flags"}
                        & $main::flags{"dark"}{"value"}
                    )
                )
                )
            {
                $return .= "Contents: None" . "\n";
            }
        }
    }
    else {
        if ( $main::objects[ $args{target} ]{"type"} == $main::player ) {
            $return .= "Carrying:" . "\n";
        }
        else {
            $return .= "Contents:" . "\n";
        }
        $return .= $desc . "\n";
    }
    $first = 1;
    $desc  = "";
    $found = 0;
    if (   ( $main::objects[ $args{target} ]{"type"} == $main::room )
        && ( !$args{details} ) )
    {
        foreach $e (@list) {
            $found = 1;
            if ( !$args{details} ) {
                if (( $main::objects[$e]{"type"} == $main::exit )
                    && (!(  $main::objects[$e]{"flags"}
                            & $main::flags{"dark"}{"value"}
                        )
                    )
                    )
                {
                    if ($first) {
                        $first = 0;
                    }
                    else {
                        $desc .= ", ";
                    }
                    my (@foo) = split( /;/, $main::objects[$e]{"name"} );
                    $desc .= "\x01" . $foo[0] . "," . $foo[0] . "\x02";
                }
            }
        }
        if ( !$found ) {
            $return .= "Visible Exits: None" . "\n";
        }
        else {
            $return .= "Visible Exits:" . "\n";
            $return .= $desc . "\n";
        }
    }
    $found = 0;
    $first = 1;
    $desc  = "";

    return $return;

}

sub lookBody {
    my %args = @_;
    my ($id);
    if (( $args{text} eq "" )
        || ( $args{text} eq
            ( "#" . $main::objects[ $args{actor} ]{"location"} ) )
        )
    {
        &describe(
            actor   => $args{actor},
            target  => $main::objects[ $args{actor} ]{"location"},
            details => $args{details}
        );
    }
    else {
        $id = &findContents( $main::objects[ $args{actor} ]{"location"},
            $args{text} );
        $id = &findContents( $args{actor}, $args{text} )
            if ( $id == NONE );
        if ( $id == NONE ) {
            if ( $args{details} ) {
                if ( substr( $args{text}, 0, 1 ) eq "#" ) {
                    $id = int( substr( $args{text}, 1 ) );
                    $id = &main::idBounds($id);
                }
            }
        }
        if (   ( $id == NONE )
            || ( $main::objects[$id]{"type"} == NONE ) )
        {
            Purl::comm::sendTextToPlayer( $args{actor},
                "I don't see that here." );
            return;
        }
        &describe(%args);
    }
}

sub recycleById {
    my %args = @_;
    if ( $main::objects[ $args{target} ]{"owner"} != $args{actor} ) {
        if ( !&Purl::tests::isWizard( $args{actor} ) ) {
            Purl::comm::sendTextToPlayer( $args{actor},
                "You don't own that!" )
                if ( !$args{quiet} );
            return;
        }
    }
    if ( $main::objects[ $args{target} ]{"type"} == $main::player ) {
        Purl::comm::sendTextToPlayer( $args{actor},
            "You must \@toad players before recycling them." )
            if ( !$args{quiet} );
        return;
    }
    if ( ( $args{target} == 0 ) || ( $args{target} == 1 ) ) {
        Purl::comm::sendTextToPlayer( $args{actor},
            "Objects #0 and #1 are indestructible." )
            if ( !$args{quiet} );
        return;
    }

    #Remove it from its location

    &removeContents( $main::objects[ $args{target} ]{"location"},
        $args{target} );

    #Find all entrances and link them to the void
    my ($i);
    for ( $i = 0; ( $i <= $#main::objects ); $i++ ) {
        $main::objects[$i]{"action"} = 0
            if ( $main::objects[$i]{"action"} == $args{target} );
    }

    #Reset the flags to keep anything funny like a puzzle
    #flag from interfering with the removal of the contents

    $main::objects[ $args{target} ]{"flags"} = 0;

    #Send the contents home. If they live here,
    #recycle them too, unless they are players.
    #If they are players, set their homes to room 0
    #and send them home.

    my @list = split( /,/, $main::objects[ $args{target} ]{"contents"} );
    foreach my $e (@list) {
        if ( $main::objects[$e]{"home"} == $args{target} ) {
            if ( $main::objects[$e]{"type"} == $main::player ) {
                $main::objects[$e]{"home"} = 0;
            }
            else {
                &recycle( $args{actor}, "#" . $e, "", "" );
                next;
            }
        }
        &sendHome($e);
    }

    Purl::comm::sendTextToPlayer( $args{actor},
        $main::objects[ $args{target} ]{"name"} . " recycled." )
        if ( !$args{quiet} );

    #Mark it unused
    $main::objects[ $args{target} ] = {};

    # I promise I won't introduce more of this stupidity
    $main::objects[ $args{target} ]{"type"}     = NONE;
    $main::objects[ $args{target} ]{"activeFd"} = NONE;
}

sub dropAll {
    my ($container) = @_;
    my (@list);
    @list = split( /,/, $main::objects[$container]{"contents"} );
    foreach my $e (@list) {
        &command( $container, "drop #" . $e );
    }
    Purl::comm::sendTextToPlayer( $container,
        "You are not carrying anything." )
        if ( !int(@list) );
}

sub sendHome {
    my %args = @_;
    &dropAll( $args{actor} )
        if (
        $main::objects[ $main::objects[ $args{actor} ]{"location"} ]{"flags"}
        & $main::flags{"puzzle"}{"value"} );
    &removeContents( $main::objects[ $args{actor} ]{"location"},
        $args{actor} );
    Purl::comm::_send_text_to_contents( $main::objects[ $args{actor} ]{"location"},
        NONE, $main::objects[ $args{actor} ]{"name"} . " goes home." )
        if (
        !(  $main::objects[ $main::objects[ $args{target} ]{"location"} ]
            {"flags"} & $main::flags{"grand"}{"value"}
        )
        );
    &addContents( $main::objects[ $args{actor} ]{"home"}, $args{actor} );
    Purl::comm::_send_text_to_contents(
        $main::objects[ $args{actor} ]{"location"},    
        $args{actor},
        $main::objects[ $args{actor} ]{"name"} . " arrives at home."
        )
        if (
        !(  $main::objects[ $main::objects[ $args{target} ]{"location"} ]
            {"flags"} & $main::flags{"grand"}{"value"}
        )
        );
    Purl::comm::sendTextToPlayer(
        actor => $args{actor},
        text  => "You go home."
    );
    Purl::Commands::run($args{actor},"look" );
}

sub setField {
    my %args = @_;
    ( $args{target}, $args{text} ) = split( / /, $args{text}, 2 );
    my ($id);
    if ( substr( $args{target}, 0, 1 ) ne "#" ) {
        $id = &findContents( $args{actor}, $args{target} );
        $id = &findContents( $main::objects[ $args{actor} ]{"location"},
            $args{target} )
            if ( $id == NONE );
    }
    else {
        $id = substr( $args{target}, 1 );
        $id = &main::idBounds($id);
    }
    if ( $id == NONE ) {
        Purl::comm::sendTextToPlayer( $args{actor},
            "I don't see that here." );
        return NONE;
    }
    else {
        if (   ( $main::objects[$id]{"owner"} != $args{actor} )
            && ( !&Purl::tests::isWizard( $args{actor} ) ) )
        {
            Purl::comm::sendTextToPlayer(
                target => $args{actor},
                text   => "That doesn't belong to you!"
            );
            return NONE;
        }
        else {
            $main::objects[ $args{target} ]{ $args{field} } = $args{text};
            if ( $args{text} eq "" ) {
                Purl::comm::sendTextToPlayer(
                    target => $args{actor},
                    text   => $args{target} . " cleared."
                );
            }
            else {
                Purl::comm::sendTextToPlayer(
                    target => $args{actor},
                    text   => $args{target} . " set."
                );
            }
        }
    }
    return $id;
}

sub getIdsSpokenTo {
    my %args = @_;
    my (@refs) = split( /,/, $args{target} );
    my ( @ids, $i, $id );
    for $i (@refs) {
        $i = &Purl::filter::canonicalizeWord( $args{actor}, $i );
        if ( $i =~ /^#(.*)/ ) {
            $id = &main::idBounds($1);
        }
        else {
            $i =~ tr/A-Z/a-z/;
            if ( !exists( $main::playerIds{$i} ) ) {
                $id = &findContents(
                    $main::objects[ $args{actor} ]{"location"},
                    $i, $main::player );
                if ( $id == NONE ) {
                    Purl::comm::sendTextToPlayer(
                        target => $args{actor},
                        text   => "Sorry, there is no player named $i.\n"
                    );
                    next;
                }
            }
            else {
                $id = $main::playerIds{$i};
            }
        }
        if ( $main::objects[$id]{"activeFd"} == NONE ) {
            Purl::comm::sendTextToPlayer(
                target => $args{actor},
                text   => "$i is not logged in."
            );
            next;
        }
        if ( $main::objects[$id]{"type"} != $main::player ) {
            Purl::comm::sendTextToPlayer(
                target => $args{actor},
                text   => "$i is an inanimate object."
            );
            next;
        }
        push @ids, $id;
    }
    return @ids;
}

sub setLock {
    my %args = @_;
    my ($id);
    $id = &setField( $args{actor}, $args{text}, "lock", "Lock" );
    return if ( $id == NONE );

    # Canonicalize the lock now, not when the lock is tested
    my ( $lock, $i, $word, $expr, $len, @words, $c );
    $lock = $main::objects[$id]{"lock"};
    $word = "";
    $expr = "";
    $len  = length($lock);
    for ( $i = 0; ( $i < $len ); $i++ ) {
        $_ = $c = substr( $lock, $i, 1 );
        if (/[\(\)\&\|\!]/) {
            if ( $word ne "" ) {
                $word = &visibleCanonicalizeWord( $args{actor}, $word );
                $expr .= $word;
            }
            $expr .= $c;
            $word = "";
        }
        else {
            $word .= $c;
        }
    }
    $expr .= &visibleCanonicalizeWord( $args{actor}, $word )
        if ( $word ne "" );
    $main::objects[$id]{"lock"} = $expr;
}

sub setDescription {
    my %args = @_;
    &setField( %args, field => "description", name => "Description" );
}

sub setFail {
    my %args = @_;
    &setField( %args,, field => "fail", "name=>Fail" );
}

sub setOfail {
    my %args = @_;
    &setField( %args,, field => "ofail", name => "Ofail" );
}

sub setOdrop {
    my %args = @_;
    &setField( %args, field => "odrop", name => "Odrop" );
}

sub setSuccess {
    my %args = @_;
    &setField( %args, field => "success", name => "Success" );
}

sub setOsuccess {
    my %args = @_;
    &setField( %args, field => "osuccess", name => "Osuccess" );
}

sub debug {
    my %args   = @_;
    my $target = $args{text};
    Purl::comm::sendTextToPlayer(
        target => $args{actor},
        text   => "DEBUG ON $main::objects[$target]{'name'}"
    );
    foreach my $key ( sort keys %{ $main::objects[$target] } ) {
        my $string = $key . ": " . $main::objects[$target]{$key};
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => $string
        );
    }
}

1;
